home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / examples / xm / menu-stuff < prev    next >
Text File  |  1991-08-05  |  2KB  |  48 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; Auxiliary definitions for the menu demos
  4.  
  5. (define (create-menu-bar parent)
  6.   (create-managed-widget (find-class 'row-column) parent
  7.     'row-column-type 'menu-bar))
  8.  
  9. (define (create-menu type parent args)
  10.   (define grand-parent (widget-parent parent))
  11.   (if (and (not (eq? grand-parent 'none))
  12.        (eq? (widget-class grand-parent) (find-class 'menu-shell)))
  13.       (set! parent grand-parent))
  14.   (let ((shell (create-popup-shell (find-class 'menu-shell)
  15.                    parent 'width 100 'height 100)))
  16.     (apply create-widget (find-class 'row-column) shell
  17.                      'row-column-type type args)))
  18.  
  19. (define (create-popup-menu parent . args)
  20.   (create-menu 'menu-popup parent args))
  21.  
  22. (define (create-pulldown-menu parent . args)
  23.   (create-menu 'menu-pulldown parent args))
  24.  
  25. (define (create-option-menu parent . args)
  26.     (apply create-managed-widget (find-class 'row-column) parent
  27.                  'row-column-type 'menu-option args))
  28.  
  29. (define (create-cascade-pulldown parent pulldown . args)
  30.   (let ((button (create-managed-widget (find-class 'cascade-button) parent)))
  31.     (set-values! button 'sub-menu-id pulldown)
  32.     (apply set-values! button args)
  33.     button))
  34.  
  35. (define (menu-add-item! type menu args)
  36.   (let ((item (create-managed-widget (find-class type) menu)))
  37.     (apply set-values! item args)
  38.     item))
  39.  
  40. (define (menu-add-label! menu . args)
  41.   (menu-add-item! 'label menu args))
  42.  
  43. (define (menu-add-separator! menu . args)
  44.   (menu-add-item! 'separator menu args))
  45.  
  46. (define (menu-add-button! menu . args)
  47.   (menu-add-item! 'push-button menu args))
  48.